###########################################################################
#
#   Copyright 2010 American Public Media Group
#
#   This file is part of AIR2.
#
#   AIR2 is free software: you can redistribute it and/or modify
#   it under the terms of the GNU General Public License as published by
#   the Free Software Foundation, either version 3 of the License, or
#   (at your option) any later version.
#
#   AIR2 is distributed in the hope that it will be useful,
#   but WITHOUT ANY WARRANTY; without even the implied warranty of
#   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#   GNU General Public License for more details.
#
#   You should have received a copy of the GNU General Public License
#   along with AIR2.  If not, see <http://www.gnu.org/licenses/>.
#
###########################################################################

package AIR2::Searcher;
use strict;
use warnings;
use base qw( Rose::ObjectX::CAF );
use Carp;
use Data::Dump qw( dump );
use AIR2::SearchUtils;
use Search::Query;
use Search::Query::Dialect::KSx;
use Search::OpenSearch;
use Lingua::Stem::Snowball;
use Digest::MD5 qw( md5_hex );
use Path::Class::File::Stat;
use JSON::XS;
use List::Util qw( shuffle );
use DBI;
use CHI;
use XML::Simple;
use KinoSearch::Index::Indexer;
use KinoSearch::Index::IndexReader;

__PACKAGE__->mk_accessors(qw( idxname quiet ));

my $CACHE_TTL = 60 * 60 * 2;    # 2 hours

umask(0007);                    # cache group rw, world null
my $cache_dir = Path::Class::Dir->new('/tmp/air2/search/cache');
$cache_dir->mkpath();

# global cache for facets
my $FACET_CACHE = CHI->new(
    driver           => 'File',
    root_dir         => "$cache_dir/facets",
    dir_create_mode  => 0770,
    file_create_mode => 0660,
);

# global cache for term suggestions
my $TERM_CACHE = CHI->new(
    driver           => 'File',
    root_dir         => "$cache_dir/terms",
    dir_create_mode  => 0770,
    file_create_mode => 0660,
);

# global cache for queries matching > 0
my $QUERY_CACHE = CHI->new(
    driver           => 'File',
    root_dir         => "$cache_dir/query",
    dir_create_mode  => 0770,
    file_create_mode => 0660,
);

# global cache for stats
my $STATS_CACHE = CHI->new(
    driver           => 'File',
    root_dir         => "$cache_dir/stats",
    dir_create_mode  => 0770,
    file_create_mode => 0660,
);

sub log {
    return if $ENV{AIR2_QUIET};
    my $self = shift;
    return if ref($self) and $self->quiet;
    my $now = localtime();
    for (@_) {
        warn join( '', '[', $now, '] [', $$, '] ', $_, "\n" );
    }
}

sub init {
    my $self = shift;
    $self->SUPER::init(@_);
    if ( !$self->idxname ) {
        my $name = ref($self);
        $name =~ s/^.+::(Active)?//;
        $name = lc($name);
        $self->idxname($name);
    }
    $self->{config}    = $self->config;
    $self->{conf_file} = $self->{config}->{index} . '/swish.xml';
    if ( !-r $self->{conf_file} ) {
        croak "no such file $self->{conf_file}: $!";
    }
    my $invmeta = XML::Simple::XMLin( $self->{conf_file} );

    # build field list to supplement what is hardcoded in config()
    for my $metaname ( keys %{ $invmeta->{MetaNames} } ) {
        my $rec = $invmeta->{MetaNames}->{$metaname};
        $self->{config}->{fields}->{$metaname} = {};
        if ( $rec->{alias_for} ) {
            push @{ $self->{config}->{fields}->{$metaname}->{alias_for} },
                $rec->{alias_for};
        }
    }

    # properties
    for my $propname ( keys %{ $invmeta->{PropertyNames} } ) {
        my $rec = $invmeta->{PropertyNames}->{$propname};
        $self->{config}->{properties}->{$propname} = {};
        if ( $rec->{alias_for} ) {
            push @{ $self->{config}->{properties}->{$propname}->{alias_for} },
                $rec->{alias_for};
        }
    }

    # add the built-ins
    $self->{config}->{fields}->{swishdefault} = {};

    $self->{invindex_meta} = $invmeta;

    return $self;
}

sub config {
    croak "you must override config() in your subclass";
}

=pod

=head1 NAME

AIR::Searcher - search library

=head1 SYNOPSIS

 use AIR::Searcher;
 my $results = AIR::Searcher->do_search({
    q => 'terms to look for',
    s => 'field_to_sort_on',
    d => 'ASC|DESC',         # sort direction
    o => 0,                  # offset (default: 0)
    p => 25,                 # page size (default: 25)
    h => 0|1,                # highlight query terms in snippet extract
    c => 0|1,                # return count only (no facets or results)
    L => 'field|low|high',   # limit results to an inclusive range
    f => 0,                  # return facets
    r => 1,                  # return results
    M => 'field',            # set default field name in transform_query()
    u => 0|1,                # return UUIDs only for results, no properties.
 });

=head1 DESCRIPTION

AIR::Searcher is the Perl interface for searching a Swish3 index.
It is designed to be run under a persistent process.

=head1 PARAMETERS

The do_search() method takes a hashref of parameters as outlined in the SYNOPSIS
section. If you are accessing this class via the web interface, the hash key/value
pairs can be passed as POST or GET parameters.

=cut

sub do_search {
    my $self   = shift;
    my $params = shift or die "params hash ref required\n";
    my $opts   = $self->parse_params($params);
    my $q      = $opts->{q};
    if ( !defined($q) or !length($q) ) {

        #return { error => 'query required', http_code => 400 };
        $q = "swishlastmodified=(not 0)";    # i.e. find everything
        $opts->{sort} = 'lastmod DESC';      # last mod first
    }
    my $query = $self->parse_query( $q, $opts->{meta_map} );

    # trac #1362 add unauthz_total before we transform the query
    if (    exists $opts->{authz}
        and defined $opts->{authz}->{authz}
        and exists $opts->{authz}->{user}->{type}
        and $opts->{authz}->{user}->{type} ne "S" )
    {
        $opts->{org_masks}
            = AIR2::SearchUtils::unpack_authz( $opts->{authz}->{authz} );
    }
    my $unauthz_total;
    eval {
        $unauthz_total = $self->get_engine->searcher->search($query)->hits;
    };

    # rethrow any errors (TODO necessary?)
    croak $@ if $@;

    $query = $self->transform_query( $query, $opts->{org_masks} );
    my $response = $self->search( $query, $opts );
    $response->unauthz_total($unauthz_total);
    return $response;
}

sub do_stats {
    my $self = shift;
    my $params = shift or die "params hash ref required\n";

    $self->log("start stats");

    my %stats;

    if ( $STATS_CACHE->get('terms') ) {
        $stats{terms} = $STATS_CACHE->get('terms');

    }
    else {

        %stats = ( terms => [] );

        # TODO make this configurable.
        my $TOP = 100;

        # grab top terms by frequency
        my $db = $self->{config}->{index} . '/../var/term.db';
        my $dbh
            = DBI->connect( "dbi:SQLite:dbname=$db", "", "",
            { RaiseError => 1, AutoCommit => 1 } )
            or die "can't connect to $db: $!";
        my $sth = $dbh->prepare(
            "SELECT term,ndocs FROM terms ORDER BY ndocs DESC LIMIT ?");
        $sth->execute($TOP);
        my @terms;
        my %terms;
        while ( my $row = $sth->fetch ) {
            push @terms, $row->[0];
            $terms{ $row->[0] } = $row->[1];
        }

        # phrases too
        $sth = $dbh->prepare(
            "SELECT phrase,ndocs FROM phrases ORDER BY ndocs DESC LIMIT ?");
        $sth->execute($TOP);
        while ( my $row = $sth->fetch ) {
            push @terms, $row->[0];
            $terms{ $row->[0] } = $row->[1];
        }

        $self->log("start term shuffle");

        # we track array and hash above so we can shuffle the order
        # for the tag cloud
        @terms = shuffle(@terms);
        for (@terms) {
            push @{ $stats{terms} }, { term => $_, freq => $terms{$_} };
        }
        $self->log("end term shuffle");

        $self->log("caching freq terms");

        $STATS_CACHE->set( 'terms', $stats{terms}, $CACHE_TTL );

    }    # end cache check

    $self->log("end stats");

    return \%stats;

}

sub parse_params {
    my $self = shift;
    my $params = shift or croak "params required";
    my %opts;

    $opts{q} = $params->{q} || $params->{query};
    $opts{sort} = $params->{s} || $params->{sort} || 'swishrank DESC';
    $opts{dir}    = $params->{d} || $params->{dir} || '';  # direction in sort
    $opts{offset} = $params->{o} || $params->{start} || 0;
    $opts{size}   = $params->{p} || $params->{limit} || 25;
    $opts{hilite} = $params->{h};
    $opts{hilite} = 1
        unless ( defined $opts{hilite} and length $opts{hilite} );
    $opts{count_only}    = $params->{c} || $params->{count_only} || 0;
    $opts{limits}        = $params->{L} || [];
    $opts{meta_map}      = $params->{M} || 0;
    $opts{return_facets} = $params->{f} || 0;
    $opts{facet_cache_ok} = $params->{no_cache} ? 0 : 1;    # TODO support?
    $opts{uuids_only}     = $params->{u} || 0;
    $opts{return_results} = $params->{r};
    $opts{return_results} = 1 unless defined $opts{return_results};
    $opts{resp_format}    = $params->{format} || 'JSON';
    $opts{authz}          = decode_json( $params->{auth_tkt} );
    $opts{boolop}         = $params->{b};

    # map "rank" to swishrank
    $opts{sort} =~ s/\brank\b/swishrank/gi;

    # concat sort+dir if necessary
    if ( length $opts{dir} and $opts{sort} !~ m/asc|desc/i ) {
        $opts{sort} .= ' ' . $opts{dir};
    }

    # only system users may avoid the required authz string
    if ((      !defined $opts{authz}->{authz}
            or !length $opts{authz}->{authz}
        )
        and ( exists $opts{authz}->{user}->{type}
            and $opts{authz}->{user}->{type} ne "S" )
        )
    {
        croak "Permission denied: missing authz for non-SYSTEM user.";
    }

    $self->log( dump( \%opts ) );

    return \%opts;
}

=head2 parse_query( I<string>, I<meta_map> )

Returns a Search::Query::Dialect object.

=cut

sub parse_query {
    my ( $self, $q, $meta_map ) = @_;
    my %args = (
        fields  => $self->{config}->{fields},
        dialect => 'KSx',
    );
    if ($meta_map) {
        $args{default_field} = $meta_map;
    }
    elsif ( exists $self->{config}->{default_field} ) {
        $args{default_field} = $self->{config}->{default_field};
    }

    # syntactic sugar for finding empty fields
    $q =~ s/(\w+)[:=]NULL/$1!=?*/g;

    #$self->log( dump \%args );
    my $parser = Search::Query->parser(%args);
    my $query = $parser->parse($q) or die $parser->error;
    $self->log("query parsed: '$query'");
    return $query;
}

=head2 transform_query( I<query> )

Returns I<query> object updated with any server-side mutations.
Examples include always adding a:

 pin_status=active

clause.

=cut

sub transform_query {
    my ( $self, $query, $org_masks ) = @_;
    $query = $self->apply_authz( $query, $org_masks );
    $self->log("transformed query: '$query'");
    return $query;
}

sub get_authz_string {
    my ( $self, $org_masks ) = @_;
    return sprintf( "%s=(%s)",
        $self->authz_field, join( ' OR ', map {$_} keys %$org_masks ) );
}

sub apply_authz {
    my ( $self, $query, $org_masks ) = @_;

    return $query unless defined $org_masks;

    # apply authz filter to exclude results for which the requester
    # does not have privileges.
    my $authz_str = $self->get_authz_string($org_masks);
    $query = $query->parser->parse("($query) AND ($authz_str)");

    return $query;
}

sub get_result_field_names {
    my $self = shift;
    my @fields = grep { !$self->{config}->{properties}->{$_}->{alias_for} }
        keys %{ $self->{config}->{properties} };
    return \@fields;
}

sub no_hilite {
    return [];
}

sub engine_class   {'KSx'}
sub snipper_config {0}
sub authz_field    { croak "$_[0] must implement authz_field" }

sub hiliter_config {
    return { class => 'highlight', };
}

sub parser_config {
    my $self     = shift;
    my $snowball = Lingua::Stem::Snowball->new(
        lang     => 'en',
        encoding => 'UTF-8',
    );
    my $stemmer = sub {
        my ( $qp, $term ) = @_;
        return $snowball->stem($term);
    };

    return {
        query_dialect => 'Search::Query::Dialect::KSx',
        ignore_fields => [
            @{ $self->config->{facet_names} },
            @{ $self->no_hilite },
            $self->authz_field
        ],

        #debug         => 1,

        # TODO based on usability test.
        # stemmer makes hiliting and snipping promiscuous.
        stemmer => $stemmer,
    };
}

sub get_engine {
    my $self = shift;

    # cache searcher, but re-spawn if invindex changes
    if ( !$self->{swish_xml} ) {
        $self->{swish_xml}
            = Path::Class::File::Stat->new( $self->{conf_file} );
    }
    my $engine_class = $self->engine_class;
    if ( !$self->{engine} or $self->{swish_xml}->changed ) {
        $self->log("spawning new engine for $self");
        $self->{engine} = Search::OpenSearch->engine(
            index          => [ $self->{config}->{index} ],
            facets         => { names => $self->{config}->{facet_names} },
            fields         => $self->get_result_field_names,
            type           => $engine_class,
            do_not_hilite  => { map { $_ => $_ } @{ $self->no_hilite } },
            snipper_config => $self->snipper_config,
            hiliter_config => $self->hiliter_config,
            parser_config  => $self->parser_config,
            logger         => $self,
            cache          => $FACET_CACHE,
            cache_ttl      => $CACHE_TTL,
        );
    }
    return $self->{engine};
}

sub search {
    my ( $self, $query, $opts ) = @_;
    my $response;
    if ( $opts->{uuids_only} ) {
        $response = $self->get_engine->get_uuids_only(
            q      => "$query",
            p      => $opts->{size},
            b      => $opts->{boolop},
            format => $opts->{resp_format},
            authz  => $opts->{org_masks},
        );
    }
    else {
        $response = $self->get_engine->search(
            q      => "$query",
            s      => $opts->{sort},
            o      => $opts->{offset},
            p      => $opts->{size},
            h      => $opts->{hilite},
            c      => $opts->{count_only},
            L      => $opts->{limits},
            f      => $opts->{return_facets},
            r      => $opts->{return_results},
            b      => $opts->{boolop},
            format => $opts->{resp_format},
            authz  => $opts->{org_masks},
        );
        $self->log( "search complete (" . $response->{total} . " hits)" );
    }
    return $response;
}

# TODO authz?
# TODO use Engine->DELETE method
sub delete_document {
    my $self     = shift;
    my $document = shift;
    my $ks       = KinoSearch::Index::Indexer->new(
        index => $self->{config}->{index} );
    $self->log("deleting $document\n");

    my $docs_before = KinoSearch::Index::IndexReader->open(
        index => $self->{config}->{index} )->doc_count();

    #$self->log("docs_before=$docs_before");

    my $ret = $ks->delete_by_term(
        field => 'swishdocpath',
        term  => $document,
    );
    $ks->commit();

    my $docs_after = KinoSearch::Index::IndexReader->open(
        index => $self->{config}->{index} )->doc_count();

    #$self->log("docs_after=$docs_after");

    # tell all searchers to reload
    $self->get_engine();    # so swish_xml is defined
    $self->{swish_xml}->touch();

    return { deleted => ( $docs_before - $docs_after ) };
}

1;
